Ian & Stuart's Australian Mac 1993 September/September 93.iso/Archives/Games/Strategy/Puzzle/GameMaster/GM Dev Kit/Rulebook Sources/File Transfer ƒ/File Transfer.p

Text File | 1991-12-04 | 12.6 KB | 608 lines | [TEXT/PJMM]

unit FileTransfer;

{ File Transfer © Peter Lewis, Oct 1991 }
{ This program and its source are Povertyware }

interface

{ Combining the world's most boring game with the world's slowest ever file transfer }
{ (OK, so the file transfer we used to send a file IN thru a centronics printer port }
{ might have been a bit slower, but this one is almost as good :-) }

    uses
        GameTypes, FixMath;

    procedure Main (var ger: gameEventRecord);

implementation

    const
        PAvailable = fsCurPerm;
        PIn = fsRdPerm;
        POut = fsWrPerm;
        PInOut = fsRdWrPerm;
        PShared = fsRdWrShPerm;

    const
        dialog_button = 1;
        dialog_fillbar = 2;
        my_dialog_item = 3;
        max_msg_len = 240;
        bad_refnum = 8000;

{ Format}
{ name:string[63] (ie, 64 bytes) }
{ Type:OSType}
{ Creator:OSType}
{ Flags:integer}
{ DataLen:longInt}
{ RsrcLen:longInt}
{ Datafork (DataLen bytes)}
{ Rsrcfork (RsrcLen bytes)}

    type
        header = packed record
                name: str63;
                typ: OSType;
                crt: OSType;
                flags: integer;
                datalen: longInt;
                rsrclen: longInt;
            end;
        connectionStateType = (cs_Local, cs_Remote);
        globalsPeek = ptr;
        block = packed array[1..max_msg_len] of byte;
        fork = (F_None, F_GotHeader, F_Data, F_Rsrc, F_Both);
        filespec = record
                head: header;
                vrn: integer;
                dirID: longInt;
                refnum: integer;
                remains: longInt;
                state: fork;
            end;
        gameRecord = record
                globals: globalsPeek;
                connectionstate: connectionStateType;
                send, receive: filespec;
            end;
        gamePeek = ^gameRecord;

    procedure Fail (s: str255);
    begin
        DebugStr(s);
    end;

    procedure MyDebug (s: string; n: longint);
        var
            numstr: str255;
    begin
        NumToString(n, numstr);
        DebugStr(concat(s, numstr));
    end;

    procedure DrawGame (wp: windowPtr; item: integer);
        var
            ggame: gamePeek;
            ghandle, h: handle;
            k: integer;
            r: rect;
        procedure DrawProgress (fs: filespec; topbar: boolean; r: rect);
            procedure FillBit (r: rect; v1, v2: integer; pat: pattern);
            begin
                r.left := v1;
                r.right := v2;
                FillRect(r, pat);
            end;
            var
                black, white: pattern;
                i, mid: integer;
                count, size: longInt;
        begin
            for i := 0 to 7 do begin
                black[i] := $FF;
                white[i] := 0;
            end;
            with r do
                if topbar then
                    bottom := (top + bottom) div 2
                else
                    top := (top + bottom) div 2;
            FrameRect(r);
            InsetRect(r, 1, 1);
            with fs.head do
                case fs.state of
                    F_Data:  begin
                        size := datalen + rsrclen;
                        count := datalen - fs.remains;
                    end;
                    F_Rsrc:  begin
                        size := datalen + rsrclen;
                        count := size - fs.remains;
                    end;
                    otherwise begin
                        count := 0;
                        size := 1;
                    end;
                end;
            mid := FracMul(r.right - r.left, FracDiv(count, size));
            if topbar then begin
                FillBit(r, r.left, r.left + mid, black);
                FillBit(r, r.left + mid, r.right, white);
            end
            else begin
                FillBit(r, r.left, r.right - mid, white);
                FillBit(r, r.right - mid, r.right, black);
            end;
        end;
    begin
        ghandle := handle(GetWRefCon(wp));
        HLock(ghandle);
        ggame := gamePeek(ghandle^);
        GetDItem(wp, item, k, h, r);
        DrawProgress(ggame^.send, true, r);
        DrawProgress(ggame^.receive, false, r);
        HUnlock(ghandle);
    end;

    procedure Main (var ger: gameEventRecord);
        var
            gglobals: globalsPeek;
            ggame: gamePeek;
            gwindow: windowPtr;
            ghandle: handle;

        procedure PackStr (var b: block; len: integer; ch: char; var s: str255);
            var
                i: integer;
        begin
            s := ch;
{$PUSH}
{$R-}
            s[0] := chr(len + 1);
{$POP}
            BlockMove(@b, @s[2], len);
        end;

        procedure UnpackStr (var s: str255; var b: block; var len: integer);
            var
                i: integer;
        begin
            len := length(s) - 1;
            BlockMove(@s[2], @b, len);
        end;

        procedure SetMyTurn;
        begin
            ger.myturn := true;
        end;

        procedure NextPlayer;
        begin
            SetMyTurn;
        end;

        procedure UpdateControls;
        begin
            DrawGame(gwindow, dialog_fillbar);
        end;

        function MFSOpenDF (var rn: integer; wdrn: integer; dirID: longInt; name: str63; perm: integer): OSErr;
            var
                pb: HParamBlockRec;
        begin
            with pb do begin
                ioNamePtr := @name;
                ioVRefNum := wdrn;
                ioPermssn := perm;
                ioMisc := nil;
                ioDirID := dirID;
                MFSOpenDF := PBHOpen(@pb, false);
                rn := ioRefNum;
            end;
        end;

        function MFSOpenRF (var rn: integer; wdrn: integer; dirID: longInt; name: str63; perm: integer): OSErr;
            var
                pb: HParamBlockRec;
        begin
            with pb do begin
                ioNamePtr := @name;
                ioVRefNum := wdrn;
                ioPermssn := perm;
                ioMisc := nil;
                ioDirID := dirID;
                MFSOpenRF := PBHOpenRF(@pb, false);
                rn := ioRefNum;
            end;
        end;

        procedure CloseFork (var refnum: integer);
            var
                oe: OSErr;
        begin
            if refnum <> bad_refnum then
                oe := FSClose(refnum);
            refnum := bad_refnum;
        end;

        procedure SetButtonState;
            var
                k: integer;
                r: rect;
                h: controlHandle;
        begin
            GetDItem(gwindow, dialog_button, k, handle(h), r);
            with ggame^ do begin
                if (connectionState = cs_remote) and (send.state = F_None) then
                    HiliteControl(h, 0)
                else
                    HiliteControl(h, 255);
            end;
        end;

        procedure StartNextFork (var fs: filespec; priv: integer);
            var
                rn: integer;
                oe: OSErr;
        begin
            with fs do begin
                CloseFork(refnum);
                if state < F_Data then
                    with head do begin
                        if datalen > 0 then begin
                            oe := MFSOpenDF(rn, vrn, dirID, name, priv);
                            if oe = noErr then begin
                                state := F_Data;
                                refnum := rn;
                                remains := head.datalen;
                                exit(StartNextFork);
                            end;
                        end;
                    end;
                if state < F_Rsrc then
                    with head do
                        if rsrclen > 0 then begin
                            oe := MFSOpenRF(rn, vrn, dirID, name, priv);
                            if oe = noErr then begin
                                state := F_Rsrc;
                                refnum := rn;
                                remains := rsrclen;
                                exit(StartNextFork);
                            end;
                        end;
                state := F_none;
                SetButtonState;
            end;
        end;

        procedure DoMove (s: str255);
            var
                b: block;
                len: integer;
                count: longInt;
                oe: OSErr;
        begin
            if length(s) > 0 then
                case s[1] of
                    'H':
                        with ggame^.receive do
                            if state = F_None then begin
                                UnpackStr(s, b, len);
                                if len <> SizeOf(header) then begin
                                    ger.event := ge_SendMessage;
                                    ger.message := 'N';
                                end
                                else begin
                                    BlockMove(@b, @head, SizeOf(header));
                                    state := F_GotHeader;
                                    ger.event := ge_Ask;
                                    ger.message := concat('Receive File “', head.name, '”');
                                    ger.but1 := 'No';
                                    ger.but2 := 'Yes';
                                end;
                            end;
                    'M':
                        with ggame^.receive do
                            if state in [F_Data, F_Rsrc] then begin
                                UnpackStr(s, b, len);
                                count := len;
                                oe := FSWrite(refnum, count, @b);
                                remains := remains - len;
                                if remains <= 0 then
                                    StartNextFork(ggame^.receive, POut);
                                UpdateControls;
                            end;
                    'Y':
                        with ggame^.send do begin
                            refnum := bad_refnum;
                            StartNextFork(ggame^.send, PIn);
                            SetButtonState;
                        end;
                    'N':  begin
                        ggame^.send.state := F_None;
                        SetButtonState;
                    end;
                end;
        end;

        procedure DoIdle;
            var
                count: longInt;
                b: block;
                oe: OSErr;
        begin
            with ggame^.send do
                if state > F_GotHeader then begin
                    count := remains;
                    if count > max_msg_len then
                        count := max_msg_len;
                    oe := FSRead(refnum, count, @b);
                    PackStr(b, count, 'M', ger.message);
                    ger.event := ge_SendMessage;
                    remains := remains - count;
                    if count <= 0 then
                        StartNextFork(ggame^.send, PIn);
                    UpdateControls;
                end;
        end;

        function MFSCreate (wdrn: integer; dirID: longInt; name: str255; c, t: OSType; flags: integer): OSErr;
            var
                ooe, oe: integer;
                fi: Finfo;
        begin
            oe := HCreate(wdrn, dirID, name, c, t);
            if oe = dupFNErr then begin
                ooe := HGetFInfo(wdrn, dirID, name, fi);
                oe := HDelete(wdrn, dirID, name);
                oe := HCreate(wdrn, dirID, name, c, t);
                if (oe = noErr) and (ooe = noErr) then begin
                    fi.fdType := t;
                    fi.fdCreator := c;
                    fi.fdFlags := flags;
                    ooe := HSetFInfo(wdrn, dirID, name, fi);
                end;
            end;
            MFSCreate := oe;
        end;

        procedure DoAnswer (ans: integer);
            var
                reply: SFReply;
                pt: point;
                oe: OSErr;
        begin
            ger.event := ge_SendMessage;
            if ans = 2 then
                with ggame^.receive do begin
                    pt := point($00280028);
                    SFPutFile(pt, 'Receive file:', head.name, nil, reply);
                    if reply.good then begin
                        ger.message := 'Y';
                        head.name := reply.fname;
                        dirID := 0;
                        vrn := reply.vRefNum;
                        oe := MFSCreate(vrn, dirID, head.name, head.crt, head.typ, head.flags);
                        refnum := bad_refnum;
                        if oe <> noErr then
                            ans := -1
                        else
                            StartNextFork(ggame^.receive, POut);
                    end
                    else
                        ans := -1;
                end;
            if ans <> 2 then begin
                ger.message := 'N';
                ggame^.receive.state := F_None;
            end;
        end;

        procedure DoSend;
            var
                reply: SFReply;
                pt: point;
                typeList: SFTypelist;
                s: str255;
                fi: FInfo;
                pb: ParamBlockRec;
                b: block;
                oe: OSErr;
        begin
            pt := point($00280028);
            SFGetFile(pt, 'Send file:', nil, -1, typeList, nil, reply);
            if reply.good then begin
                with ggame^.send, head do begin
                    name := reply.fname;
                    vrn := reply.vrefnum;
                    dirID := 0;
                    with pb do begin
                        ioNamePtr := @name;
                        ioVRefNum := vrn;
                        ioVersNum := 0;
                        ioFDirIndex := 0;
                        oe := PBGetFInfo(@pb, false);
                        typ := ioFlFndrInfo.fdType;
                        crt := ioFlFndrInfo.fdCreator;
                        flags := ioFlFndrInfo.fdFlags;
                        datalen := ioFlLgLen;
                        rsrclen := ioFlRLgLen;
                    end;
                    BlockMove(@head, @b, SizeOf(header));
                    PackStr(b, SizeOf(header), 'H', ger.message);
                    ger.event := ge_SendMessage;
                    state := F_GotHeader;
                    SetButtonState;
                end;
            end;
        end;

        procedure InitRuleBook;
            var
                i: integer;
                rct: rect;
                hdl: handle;
                mid: integer;
        begin
            ger.globals := nil;
            gglobals := globalsPeek(ger.globals);
            with rct do begin
                hdl := GetResource('DITL', 128);
                if hdl = nil then begin
                    Fail('GetResource DITL failed');
                    SetRect(rct, 4, 4, 100, 100);
                end
                else
                    BlockMove(ptr(longInt(hdl^) + GetHandleSize(hdl) - 10), @rct, SizeOf(rect));
                ger.int1 := left + right; { figure out why :-}
                ger.int2 := top + bottom;
            end;
        end; {proc}

        procedure FinishRuleBook;
        begin
            ger.globals := nil;
        end;

        procedure CommonInit;
            var
                k: integer;
                h: handle;
                rct: rect;
        begin
            GetDItem(gwindow, dialog_fillbar, k, h, rct);
            SetDItem(gwindow, dialog_fillbar, k, handle(@DrawGame), rct);
            SetWRefCon(gwindow, longInt(ghandle));
            ggame^.globals := gglobals;
            with ggame^ do begin
                send.state := F_None;
                receive.state := F_None;
                connectionstate := cs_Local;
                SetButtonState;
            end;
        end;

        procedure RestartGame;
            var
                r: integer;
        begin
            SetMyTurn;
            UpdateControls;
        end;

        procedure NewGame;
        begin
            HUnlock(ghandle);
            SetHandleSize(ghandle, SizeOf(gameRecord));
            HLock(ghandle);
            ggame := gamePeek(ghandle^);
            CommonInit;
            RestartGame;
        end;

        procedure OldGame;
        begin
            CommonInit;
            SetMyTurn;
            UpdateControls;
        end;

        procedure Swap;
        begin
            SetMyTurn;
            UpdateControls;
        end;

        procedure ConnectionLost;
            procedure Finish (var fs: filespec);
                var
                    oe: OSErr;
            begin
                fs.state := F_None;
                if fs.refnum <> bad_refnum then
                    oe := FSClose(fs.refnum);
                fs.refnum := bad_refnum;
            end;
        begin
            with ggame^ do begin
                with ggame^ do begin
                    Finish(send);
                    Finish(receive);
                    connectionstate := cs_Local;
                    SetButtonState;
                end;
                SetMyTurn;
            end; {with}
        end;

        procedure ConnectionMade;
        begin
            with ggame^ do begin
                connectionstate := cs_Remote;
                SetButtonState;
                SetMyTurn;
            end; {with}
        end;

        procedure Restart;
        begin
            RestartGame;
        end;

        procedure MouseDown;
        begin
            if (ger.int1 = dialog_button) and (ggame^.connectionState = cs_remote) then
                DoSend;
        end;

        procedure MessageReceived;
        begin
            DoMove(ger.message);
        end;

        procedure AnswerReceived;
        begin
            DoAnswer(ger.int1);
        end;

    begin
        gglobals := globalsPeek(ger.globals);
        ghandle := ger.game;
        if ghandle <> nil then begin
            HLock(ghandle);
            ggame := gamePeek(ghandle^);
        end;
        GetPort(gwindow);
        case ger.event of
            ge_InitRuleBook:
                InitRuleBook;
            ge_FinishRuleBook:
                FinishRuleBook;
            ge_NewGame:
                NewGame;
            ge_OldGame:
                OldGame;
            ge_ConnectionLost:
                ConnectionLost;
            ge_ConnectionMade:
                ConnectionMade;
            ge_MessageReceived:
                MessageReceived;
            ge_Answer:
                AnswerReceived;
            ge_MouseDown:
                MouseDown;
            ge_Swap:
                Swap;
            ge_Restart:
                Restart;
            ge_Idle:
                DoIdle;
            otherwise
        end;
        if ghandle <> nil then
            HUnlock(ghandle);
    end;

end.